home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Matts-utils.sea / Matts-utils / draw-arrow.lisp / draw-arrow.lisp
Encoding:
Text File  |  1992-08-12  |  4.9 KB  |  133 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; draw-arrow.lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Defines the draw-arrow function. Contributed by seth@aic.hrl.hac.com .
  10. Modified by Matthew Cornell, cornell@cs.umass.edu.
  11.  
  12.  
  13. ================================================================
  14. Status =========================================================
  15. ================================================================
  16. Usable.
  17.  
  18. Bug: Doesn't check (window-color-p (view-window view)) or *color-available* .
  19.  
  20.  
  21. ================================================================
  22. Change history =================================================
  23. ================================================================
  24. 11-Aug-92 mc    Created from seth@aic.hrl.hac.com's source.
  25.         Removed Quickdraw.lisp dependencies.
  26.         Fixed color passing.
  27.         Made into a view method.
  28.         Moved draw-triangle into a labels.
  29.         Passing color, macptr-pattern, and num-arrow-length keywords.
  30.  
  31. |#
  32.  
  33.  
  34. (in-package "CCL")
  35.  
  36. (export '(DRAW-ARROW
  37.           )
  38.         "CCL")
  39.  
  40.  
  41. ;;;================================================================
  42. ;;; Define the draw-arrow function and friends.
  43. ;;;================================================================
  44.  
  45. (defgeneric draw-arrow (view pt-start pt-end
  46.                               &key color num-arrow-length
  47.                               macptr-pattern)
  48.   (:documentation "Draws an arrow in view from pt-start to pt-end. The
  49. keywords customize its size and appearance."))
  50.  
  51.  
  52. (defmethod draw-arrow ((view view)
  53.                         (pt-start integer)
  54.                         (pt-end integer)
  55.                         &key (color *black-color*)
  56.                         (num-arrow-length 16.0)
  57.                         (macptr-pattern *black-pattern*))
  58.   (labels ((draw-triangle (pt-end p2 p3 &aux poly)
  59.              (setq poly (#_openpoly :ptr))
  60.              (#_moveto :long pt-end)
  61.              (#_lineto :long p2)
  62.              (#_lineto :long p3)
  63.              (#_lineto :long pt-end)
  64.              (#_closepoly)
  65.              (#_paintpoly :ptr poly)
  66.              (#_killpoly :ptr poly)))
  67.     (let* ((xdiff (- (point-h pt-end) (point-h pt-start)))
  68.            (ydiff (- (point-v pt-end) (point-v pt-start)))
  69.            (ang (if (zerop ydiff)
  70.                   (if (< xdiff 0) 4.7124 1.5708)  ; 3/2 pi or 1/2 pi
  71.                   (atan (/ xdiff ydiff))))
  72.            (angdiff (if (< ydiff 0) 0.25 2.8916))
  73.            (ang1 (+ ang angdiff))
  74.            (ang2 (- ang angdiff))
  75.            (p2 (make-point (+ (round (* num-arrow-length (sin ang1))) (point-h pt-end))
  76.                            (+ (round (* num-arrow-length (cos ang1))) (point-v pt-end))))
  77.            (p3 (make-point (+ (round (* num-arrow-length (sin ang2))) (point-h pt-end))
  78.                            (+ (round (* num-arrow-length (cos ang2))) (point-v pt-end)))))
  79.       (with-focused-view view
  80.         (with-fore-color color
  81.           (with-pen-saved
  82.             (#_PenPat macptr-pattern)
  83.             (#_MoveTo :long pt-start)
  84.             (#_LineTo :long pt-end)
  85.             (draw-triangle pt-end p2 p3)))))))
  86.  
  87.  
  88. ;;; Done.
  89.  
  90. (provide "DRAW-ARROW")
  91.  
  92.  
  93. #|;;; Define testing functions.
  94.  
  95. (defun select-randomly-from-sequence (sequence)
  96.   "Returns a randomly-selected element from sequence."
  97.   ;;
  98.   (elt sequence (random (length sequence))))
  99.  
  100.  
  101. (defun test-draw-arrow ()
  102.   "Draws arrows while the mouse is down."
  103.   ;;
  104.   (let* ((view (make-instance 'window :window-title "Test Draw Arrow"
  105.                               :view-size #@(400 300))))
  106.     (defmethod view-click-event-handler ((view (eql view))
  107.                                          (pt-where integer))
  108.       (let ((pt-center (make-point (round (point-h (view-size view)) 2)
  109.                                    (round (point-v (view-size view)) 2)))
  110.             (num-arrow-length (+ 5 (random 20)))
  111.             (macptr-pattern
  112.              (select-randomly-from-sequence
  113.               (list *BLACK-PATTERN* *DARK-GRAY-PATTERN* *GRAY-PATTERN*
  114.                     *LIGHT-GRAY-PATTERN* ;*WHITE-PATTERN*
  115.                     )))
  116.             (color
  117.              (select-randomly-from-sequence
  118.               (list *BLACK-COLOR* *BLUE-COLOR* *BROWN-COLOR* *DARK-GRAY-COLOR*
  119.                     *DARK-GREEN-COLOR* *GRAY-COLOR* *GREEN-COLOR*
  120.                     *LIGHT-BLUE-COLOR* *LIGHT-GRAY-COLOR* *ORANGE-COLOR*
  121.                     *PINK-COLOR* *PURPLE-COLOR* *RED-COLOR* *TAN-COLOR*
  122.                     ;*WHITE-COLOR*
  123.                     *YELLOW-COLOR*))))
  124.         (rlet ((macptr-rect :rect :topLeft #@(0 0)
  125.                             :bottomRight (view-size view)))
  126.           (#_EraseRect macptr-rect))
  127.         (loop while (#_StillDown) do
  128.               (draw-arrow view pt-center (view-mouse-position view)
  129.                           :color color :macptr-pattern macptr-pattern
  130.                           :num-arrow-length num-arrow-length))))
  131.     ;;
  132.     view))
  133. |#